home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / akcl / kcl.lha / cmpnew / cmptest.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1987-06-03  |  7.5 KB  |  253 lines
  1. ;;; CMPTEST  Functions for compiler test.
  2. ;;;
  3. ;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  4. ;; Copying of this file is authorized to users who have executed the true and
  5. ;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  6.  
  7. (in-package 'compiler)
  8.  
  9. (defun self-compile ()
  10.  (with-open-file (log "lsplog" :direction :output)
  11.   (let ((*standard-output* (make-broadcast-stream *standard-output* log)))
  12.  
  13. ;       (self-compile2 "cmpbind")
  14. ;       (self-compile2 "cmpblock")
  15. ;       (self-compile2 "cmpcall")
  16. ;       (self-compile2 "cmpcatch")
  17.        (self-compile2 "cmpenv")
  18. ;       (self-compile2 "cmpeval")
  19. ;       (self-compile2 "cmpflet")
  20. ;       (self-compile2 "cmpfun")
  21. ;       (self-compile2 "cmpif")
  22. ;       (self-compile2 "cmpinline")
  23.        (self-compile2 "cmplabel")
  24. ;       (self-compile2 "cmplam")
  25. ;       (self-compile2 "cmplet")
  26. ;       (self-compile2 "cmploc")
  27. ;       (self-compile2 "cmpmap")
  28. ;       (self-compile2 "cmpmulti")
  29. ;       (self-compile2 "cmpspecial")
  30. ;       (self-compile2 "cmptag")
  31. ;       (self-compile2 "cmptop")
  32. ;       (self-compile2 "cmptype")
  33.        (self-compile2 "cmputil")
  34. ;       (self-compile2 "cmpvar")
  35. ;       (self-compile2 "cmpvs")
  36. ;       (self-compile2 "cmpwt")
  37.  
  38.        ))
  39.  t)
  40.  
  41. (defun setup ()
  42.  
  43. ;  (allocate 'cons 800)
  44. ;  (allocate 'string 256)
  45. ;  (allocate 'structure 32)
  46. ;  (allocate-relocatable-pages 128)
  47.  
  48. ;  (load ":udd:common:cmpnew:cmpinline.lsp")
  49.   (load ":udd:common:cmpnew:cmputil.lsp")
  50. ;  (load ":udd:common:cmpnew:cmptype.lsp")
  51.  
  52. ;  (load ":udd:common:cmpnew:cmpbind.lsp")
  53. ;  (load ":udd:common:cmpnew:cmpblock.lsp")
  54.   (load ":udd:common:cmpnew:cmpcall.lsp")
  55. ;  (load ":udd:common:cmpnew:cmpcatch.lsp")
  56. ;  (load ":udd:common:cmpnew:cmpenv.lsp")
  57. ;  (load ":udd:common:cmpnew:cmpeval.lsp")
  58.   (load ":udd:common:cmpnew:cmpflet.lsp")
  59. ;  (load ":udd:common:cmpnew:cmpfun.lsp")
  60. ;  (load ":udd:common:cmpnew:cmpif.lsp")
  61.   (load ":udd:common:cmpnew:cmplabel.lsp")
  62. ;  (load ":udd:common:cmpnew:cmplam.lsp")
  63. ;  (load ":udd:common:cmpnew:cmplet.lsp")
  64.   (load ":udd:common:cmpnew:cmploc.lsp")
  65. ;  (load ":udd:common:cmpnew:cmpmain.lsp")
  66. ;  (load ":udd:common:cmpnew:cmpmap.lsp")
  67. ;  (load ":udd:common:cmpnew:cmpmulti.lsp")
  68. ;  (load ":udd:common:cmpnew:cmpspecial.lsp")
  69. ;  (load ":udd:common:cmpnew:cmptag.lsp")
  70.   (load ":udd:common:cmpnew:cmptop.lsp")
  71. ;  (load ":udd:common:cmpnew:cmpvar.lsp")
  72. ;  (load ":udd:common:cmpnew:cmpvs.lsp")
  73. ;  (load ":udd:common:cmpnew:cmpwt.lsp")
  74.  
  75. ;  (load ":udd:common:cmpnew:lfun_list")
  76. ;  (load ":udd:common:cmpnew:cmpopt.lsp")
  77.  
  78.   )
  79.  
  80. (defun cli () (process ":cli.pr"))
  81.  
  82. (defun load-fasl ()
  83.  
  84.   (load "cmpinline")
  85.   (load "cmputil")
  86.   (load "cmpbind")
  87.   (load "cmpblock")
  88.   (load "cmpcall")
  89.   (load "cmpcatch")
  90.   (load "cmpenv")
  91.   (load "cmpeval")
  92.   (load "cmpflet")
  93.   (load "cmpfun")
  94.   (load "cmpif")
  95.   (load "cmplabel")
  96.   (load "cmplam")
  97.   (load "cmplet")
  98.   (load "cmploc")
  99.   (load "cmpmap")
  100.   (load "cmpmulti")
  101.   (load "cmpspecial")
  102.   (load "cmptag")
  103.   (load "cmptop")
  104.   (load "cmptype")
  105.   (load "cmpvar")
  106.   (load "cmpvs")
  107.   (load "cmpwt")
  108.  
  109.   (load "cmpmain.lsp")
  110.   (load "lfun_list.lsp")
  111.   (load "cmpopt.lsp")
  112.  
  113.   )
  114.  
  115. (setq *macroexpand-hook* 'funcall)
  116.  
  117. (defun self-compile1 (file)
  118.   (prin1 file) (terpri)
  119.   (compile-file1 file
  120.     :fasl-file t :c-file t :h-file t :data-file t :ob-file t :system-p t))
  121.  
  122. (defun self-compile2 (file)
  123.   (prin1 file) (terpri)
  124.   (compile-file1 file
  125.     :fasl-file t :c-file t :h-file t :data-file t :ob-file t :system-p t)
  126.   (prin1 (load file)) (terpri))
  127.  
  128. (defvar *previous-form* nil)
  129.  
  130. (defun cmp (form)
  131.   (setq *previous-form* form)
  132.   (again))
  133.  
  134. (defun again ()
  135.   (init-env)
  136.   (print *previous-form*)
  137.   (terpri)
  138.   (setq *compiler-output1* *standard-output*)
  139.   (setq *compiler-output2* *standard-output*)
  140.   (setq *compiler-output-data* *standard-output*)
  141.   (let ((prev (get-dispatch-macro-character #\# #\,)))
  142.        (set-dispatch-macro-character #\# #\,
  143.                                      'si:sharp-comma-reader-for-compiler)
  144.        (unwind-protect
  145.         (t1expr *previous-form*)
  146.         (set-dispatch-macro-character #\# #\, prev)))
  147.   (catch *cmperr-tag* (ctop-write "test"))
  148.   t)
  149.  
  150. ;(defun make-cmpmain-for-unix ()
  151. ;       (print "unixmain")
  152. ;       (format t "~&The old value of *FEATURES* is ~s." *features*)
  153. ;       (let ((*features* '(unix common kcl)))
  154. ;            (format t "~&The new value of *FEATURES* is ~s." *features*)
  155. ;            (init-env)
  156. ;            (compile-file1 "cmpmain.lsp"
  157. ;                           :output-file "unixmain"
  158. ;                           :c-file t
  159. ;                           :h-file t
  160. ;                           :data-file t
  161. ;                           :system-p t
  162. ;                           ))
  163. ;       (format t "~&The resumed value of *FEATURES* is ~s." *features*)
  164. ;       )
  165.  
  166. (defun compiler-make-ufun ()
  167.   (make-ufun '(
  168.   "cmpbind.lsp"
  169.   "cmpblock.lsp"
  170.   "cmpcall.lsp"
  171.   "cmpcatch.lsp"
  172.   "cmpenv.lsp"
  173.   "cmpeval.lsp"
  174.   "cmpflet.lsp"
  175.   "cmpfun.lsp"
  176.   "cmpif.lsp"
  177.   "cmpinline.lsp"
  178.   "cmplabel.lsp"
  179.   "cmplam.lsp"
  180.   "cmplet.lsp"
  181.   "cmploc.lsp"
  182.   "cmpmain.lsp"
  183.   "cmpmap.lsp"
  184.   "cmpmulti.lsp"
  185.   "cmpspecial.lsp"
  186.   "cmptag.lsp"
  187.   "cmptop.lsp"
  188.   "cmptype.lsp"
  189.   "cmputil.lsp"
  190.   "cmpvar.lsp"
  191.   "cmpvs.lsp"
  192.   "cmpwt.lsp"
  193.  
  194.   ))
  195.  
  196.   t)
  197.  
  198. (defun remrem ()
  199.        (do-symbols (x (find-package 'lisp))
  200.                    (remprop x 'inline-always)
  201.                    (remprop x 'inline-safe)
  202.                    (remprop x 'inline-unsafe))
  203.        (do-symbols (x (find-package 'system))
  204.                    (remprop x 'inline-always)
  205.                    (remprop x 'inline-safe)
  206.                    (remprop x 'inline-unsafe)))
  207. (defun ckck ()
  208.        (do-symbols (x (find-package 'lisp))
  209.                    (when (or (get x 'inline-always)
  210.                              (get x 'inline-safe)
  211.                              (get x 'inline-unsafe))
  212.                          (print x)))
  213.        (do-symbols (x (find-package 'si))
  214.                    (when (or (get x 'inline-always)
  215.                              (get x 'inline-safe)
  216.                              (get x 'inline-unsafe))
  217.                          (print x))))
  218.  
  219. (defun make-cmpopt (&aux (eof (cons nil nil)))
  220.   (with-open-file (in "cmpopt.db")
  221.     (with-open-file (out "cmpopt.lsp" :direction :output)
  222.       (print '(in-package 'compiler) out)
  223.       (terpri out) (terpri out)
  224.       (do ((x (read in nil eof) (read in nil eof)))
  225.           ((eq x eof))
  226.           (apply #'(lambda (property return-type side-effectp new-object-p
  227.                                      name arg-types body)
  228.                      (when (stringp body)
  229.                        (do ((i 0 (1+ i))
  230.                             (l nil)
  231.                             (l1 nil))
  232.                            ((>= i (length body))
  233.                             (when l1
  234.                               (setq body
  235.                                     (concatenate 'string
  236.                                                  "@"
  237.                                                  (reverse l1)
  238.                                                  ";"
  239.                                                  body))))
  240.                          (when (char= (aref body i) #\#)
  241.                            (incf i)
  242.                            (cond ((member (aref body i) l)
  243.                                   (pushnew (aref body i) l1))
  244.                                  (t (push (aref body i) l))))))
  245.                      (print
  246.                       `(push '(,arg-types ,return-type ,side-effectp
  247.                                           ,new-object-p ,body)
  248.                              (get ',name ',property))
  249.                       out))
  250.                  (cdr x)))
  251.       (terpri out))))
  252.  
  253.